home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
User's Choice Windows CD
/
User's Choice Windows CD (CMS Software)(1993).iso
/
win_u_z
/
uc12.zip
/
CLIPOBJ.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-08-25
|
20KB
|
833 lines
UNIT ClipObj;
Interface
USES WinTypes, WinProcs, WObjects, Strings,Win31;
{$D Copyright (c) 1992 Doug Overmyer}
const
st_OK = 1;
st_ClipFailure = 2;
st_NoMem = 3;
type
PClipItem = ^TClipItem;
TClipItem = object(TObject)
CHandle:THandle;
CName:PChar;
CFormat:Word;
constructor Init(NewCHandle:THandle;NewCName:PChar;NewCFormat:Word);
destructor Done;virtual;
end;
PClipC = ^TClipC;
TClipC = object(TCollection)
constructor Init(ALimit,ADelta:Integer);
destructor Done;virtual;
end;
PClipObj = ^TClipObj;
TClipObj = OBJECT(TObject)
constructor Init(hW:HWnd;var Stat:Word;SRect:TRect);
procedure GetClip(hW : hWnd; var Stat : Word);
destructor Done; Virtual;
procedure CopyClip(hW : hWnd);
procedure RenderSelf(DC:hDC;hWin:HWnd);
procedure RedrawSelf(DC:hDC;hWin:HWnd);
function GetStatus : Word;
function GetPal : hPalette;
function GetDIB : THandle;
function GetPICT : THandle;
procedure GetInfo(Info:PChar;Len:Integer);
procedure SetIsPrefText(Choice:Bool);
procedure ToggleIsPrefText;
procedure GetFormats(Buf:PChar);
Private
Clips : PClipC;
name : ARRAY[0..80] OF Char;
hDIB : THandle;
hPal : hPalette;
hPICT : THandle;
hText :THandle;
hNative :THandle;
hBMP :HBitmap;
hDisp : HBitmap;
Status :Word;
IsPrefText :Bool;
SR : TRect; {Sizing Rectangle}
end;
{**************************** Implementation **********************}
Implementation
type
LongType = record
CASE Word OF
0: (Ptr: Pointer);
1: (Long: Longint);
2: (Lo: Word;
Hi: Word);
end;
procedure AHIncr; far; external 'KERNEL' index 114;
function _hRead(hFile:Integer;Buffer:PChar;dwBytes:LongInt):LongInt;far; external 'KERNEL';
function _hWrite(hFile:Integer;Buffer:PChar;dwBytes:LongInt):LongInt;far; external 'KERNEL';
{************************* Functions *******************************}
function LongMin(A, B: LongInt): LongInt;
begin
if A < B then LongMin := A else LongMin := B;
end;
function LongMax(A, B: LongInt): LongInt;
begin
if A > B then LongMax := A else LongMax := B;
end;
function DIBSize(Width,Height:LongInt;Res:Integer):LongInt;
begin
DIBSize := (((LongInt(Width)*RES+31) div 32) * 4) * Height;
end;
function CopyGHND(hGM1:THandle):THandle;
var
Size:LongInt;
hGM:THandle;
pGM,pGM1:Pointer;
begin
CopyGHND := 0;
Size :=GlobalSize(hGM1);
pGM1 := GlobalLock(hGM1);
IF pGM1 = NIL then Exit;
hGM :=GlobalAlloc(GHND,Size);
pGM := GlobalLock(hGM);
if pGM <> nil then
hmemCpy(pGM,pGM1,Size);
GlobalUnlock(hGM);
CopyGHND := hGM;
end;
function GetDIBColorCnt(bi:PBitmapInfo):Word;
begin
GetDIBColorCnt := bi^.bmiHeader.biClrUsed;
if bi^.bmiHeader.biClrUsed = 0 then
if bi^.bmiHeader.biBitCount <> 24 then
GetDIBColorCnt:= 1 shl bi^.bmiHeader.biBitCount;
end;
function GetDIBBits(pDIB:Pointer):Pointer;
var
bi:PBitmapInfo;
cPalColors:Word;
begin
GetDIBBits := NIL;
bi := pDIB;
cPalColors := GetDIBColorCnt(bi);
GetDIBBits := Ptr(Seg(bi^),
ofs(bi^)+sizeof(TBitmapInfoHeader)+cPalColors*sizeof(TRGBQuad));
end;
function GetDIBPal(bi:PBitmapInfo):HPalette;
var
PalSize,N,cPalColors: Word;
pal : PLogPalette;
begin
GetDIBPal := 0;
cPalColors :=GetDIBColorCnt(bi);
IF cPalColors = 0 then Exit;
PalSize := SizeOf(TLogPalette)+Pred(cPalColors)*sizeof(TPaletteEntry);
GetMem(pal, PalSize);
pal^.palVersion := $300;
pal^.palNumEntries := cPalColors;
FillChar(pal^.palPalEntry, cPalColors *sizeof(TPaletteEntry), 0);
FOR N := 0 TO pred(cPalColors) DO
WITH pal^.palPalEntry[N], bi^.bmiColors[N] DO
begin
peRed := rgbRed;
peGreen := rgbGreen;
peBlue := rgbBlue
end;
GetDibPal := CreatePalette(pal^);
FreeMem(pal, PalSize);
end;
function CopyPal(hP:hPalette):hPalette;
var
Pal : PLogPalette;
cPalColors:Word;
begin
CopyPal := 0;
if hP = 0 then Exit;
GetObject(hP,2,@cPalColors);
GetMem(Pal, sizeof(TLogPalette) + pred(cPalColors)*sizeof(TPaletteEntry));
pal^.palVersion := $300;
pal^.palNumEntries := cPalColors;
GetPaletteEntries(hP, 0, cPalColors,pal^.palPalEntry);
CopyPal := CreatePalette(pal^);
FreeMem(Pal, sizeof(TLogPalette)+pred(cPalColors)*sizeof(TPaletteEntry));
end;
function CopyBMP(hB1:HBitmap;DC:hDC): hBitmap;
var
cBits,ret:LongInt;
Bits:THandle;
pBits:Pointer;
tb:TBitmap;
hB2:HBitmap;
begin
CopyBMP := 0;
if hB1 = 0 then Exit;
GetObject(hB1,sizeof(TBitmap),@tb);
cBits := LongInt(tb.bmWidthBytes)*tb.bmHeight *tb.bmPlanes;
bits :=GlobalAlloc(GHND,cBits);
pBits := GlobalLock(Bits);
ret :=GetBitmapBits(hB1,cBits,pBits);
hB2 := CreateCompatibleBitmap(DC,tb.bmWidth,tb.bmHeight);
ret :=SetBitmapBits(hB2,cBits,pBits);
GlobalUnlock(Bits);
GlobalFree(Bits);
CopyBMP := hB2;
end;
function ScaleBMP(hB1:HBitmap;hP:HPalette;DC:hDC;SR:TRect): hBitmap;
var
cBits,ret:LongInt;
Bits:THandle;
pBits:Pointer;
tb:TBitmap;
hB2,oB1,oB2:HBitmap;
RC:TRect;
MaxXY,X,Y:LongInt;
MemDC1,MemDC2:HDC;
oP:HPalette;
begin
ScaleBMP := 0;
if hB1 = 0 then Exit;
GetObject(hB1,sizeof(TBitmap),@tb);
X:=tb.bmWidth;Y:=tb.bmHeight;
if X > Y then MaxXY :=X else MaxXY:=Y;
SetRect(RC,0,0,SR.Right*X div MaxXY,
SR.Bottom*Y div MaxXY);
MemDC1:= CreateCompatibleDC(DC);
MemDC2:= CreateCompatibleDC(DC);
hB2:=CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
oB2:=SelectObject(MemDC2,hB2);
oB1:=SelectObject(MemDC1,hB1);
if hP > 0 then oP := SelectPalette(memDC2,hP,False);
RealizePalette(memDC2);
SetStretchBltMode(memDC2,stretch_deletescans);
StretchBlt(memDC2,0,0,RC.Right,RC.Bottom,memDC1,0,0,
X,Y,SRCCopy);
if hP > 0 then SelectPalette(memDC2,oP,False);
SelectObject(memDC1,oB1);
SelectObject(memDC2,oB2);
DeleteDC(memDC1);
DeleteDC(memDC2);
ScaleBMP :=hB2;
end;
function BMPtoDIB(hB:HBitmap;hP:HPalette;DC:HDC):THandle;
var
hbi:THandle;
bi:PBitmapInfo;
tb:TBitmap;
pBits:Pointer;
hBits:THandle;
cSize:LongInt;
op:HPalette;
bRES,cColor:Integer;
begin
if hP <> 0 then
begin
op :=SelectPalette(DC,hP,false);
RealizePalette(DC);
end
else op := 0;
GetObject(hB,sizeof(TBitmap),@tb);
bRES := tb.bmPlanes*tb.bmBitsPixel;
cColor := 0;
if bRES < 24 then cColor := 1 shl bRES;
cSize :=DIBSize(tb.bmWidth,tb.bmHeight,bRes);
hbi :=GlobalAlloc(GHND,sizeof(TBitmapInfoHeader)+cColor*sizeof(TRGBQuad)+cSize);
bi := GlobalLock(hbi);
with bi^.bmiHeader do
begin
biSize:= sizeof(TBitmapInfoHeader);
biWidth :=tb.bmWidth;
biHeight := tb.bmHeight;
biPlanes := 1;
biBitCount := bRES;
biCompression := BI_RGB;
end;
pBits:=Ptr(Seg(bi^),
ofs(bi^)+sizeof(TBitmapInfoHeader)+cColor*sizeof(TRGBQuad));
GetDIBits(DC,hB,0,tb.bmHeight,pBits,bi^,DIB_RGB_Colors);
GlobalUnlock(hbi);
BMPtoDIB := hbi;
if hP > 0 then selectPalette(DC,op,false);
end;
function DIBtoBMP(H:THandle;hW:HWnd ):hBitmap;
var
bi:PBitmapInfo;
hP,oP:HPalette;
bits:Pointer;
DC:hDC;
begin
DIBtoBMP := 0;
if H = 0 then Exit;
bi := GlobalLock(H);
if bi = nil then Exit;
hP := GetDibPal(bi);
DC := GetDC(hW);
if hP > 0 then oP := SelectPalette(DC,hP,False);
RealizePalette(DC);
bits := GetDIBBits(bi);
DIBtoBMP:= CreateDIBitmap(DC, bi^.bmiHeader,
cbm_Init, bits, bi^, dib_RGB_Colors);
GlobalUnlock(H);
if hP > 0 then SelectPalette(DC,oP,False);
DeleteObject(hP);
ReleaseDC(hW,DC);
end;
function DIBtoBMPScaled(H:THandle;hW:HWnd;SR:TRect):hBitmap;
var
bi:PBitmapInfo;
hP,oP:HPalette;
bits:Pointer;
DC:hDC;
hB,oB:HBitmap;
RC:TRect;
MaxXY,X,Y:Word;
MemDC:HDC;
begin
hP:= 0;
DIBtoBMPScaled := 0;
if H = 0 then Exit;
bi := GlobalLock(H);
if bi = nil then Exit;
X:=bi^.bmiheader.biWidth;Y:=bi^.bmiheader.biHeight;
MaxXY:=LongMax(X,Y);
SetRect(RC,0,0,SR.Right * X div MaxXY,
SR.Bottom * Y div MaxXY);
hP := GetDibPal(bi);
DC := GetDC(hW);
MemDC:= CreateCompatibleDC(DC);
hB:=CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
oB:=SelectObject(MemDC,hB);
if hP > 0 then oP := SelectPalette(memDC,hP,False);
RealizePalette(memDC);
bits := GetDIBBits(bi);
SetStretchBltMode(memDC,stretch_deletescans);
StretchDIBits(memDC,0,0,RC.Right,RC.Bottom,0,0,
X,Y,bits, bi^, dib_RGB_Colors,SRCCopy);
GlobalUnlock(H);
if hP > 0 then SelectPalette(memDC,oP,False);
if hP > 0 then DeleteObject(hP);
SelectObject(memDC,oB);
DeleteDC(memDC);
DIBtoBMPScaled :=hB;
ReleaseDC(hW,DC);
end;
function CopyPICT(H:THandle):THandle;
var
mi:PMetaFilePict;
hMFP:THandle;
pMFP:PMetaFilePict;
begin
CopyPICT := 0;
mi := GlobalLock(H);
If mi = nil then EXIT;
hMFP := GlobalAlloc(GHND,sizeof(TMetaFilePict));
pMFP := GlobalLock(hMFP);
pMFP^.mm := mi^.mm;
pMFP^.xEXT := mi^.xEXT;
pMFP^.yEXT := mi^.yEXT;
pMFP^.hMF := CopyMetaFile(mi^.hMF,nil);
GlobalUnlock(H);
GlobalUnlock(hMFP);
CopyPICT := hMFP;
end;
procedure DelPICT(H:THandle);
var
pMFP:PMetaFilePict;
begin
if H = 0 then Exit;
pMFP := GlobalLock(H);
if pMFP = nil then Exit;
DeleteMetaFile(pMFP^.hMF);
GlobalUnlock(H);
GlobalFree(H);
end;
procedure GetPICTSize(H:THandle;DC:HDC;HWin:HWnd;var X,Y:LongInt);
var
om:Integer;
mfp:PMetaFilePict;
XP,YP:TPoint;
CR:TRect;
begin
XP.X := 0;XP.Y:=0;YP.X:=0;YP.Y:= 0;
GetClientRect(HWin,CR);
if H = 0 then Exit;
mfp := GlobalLock(H);
if mfp = nil then Exit;
if (mfp^.mm = MM_ISOTROPIC) OR (mfp^.mm = MM_ANISOTROPIC) then
om := SetMapMode(DC,MM_HIMETRIC)
else
om := SetMapMode(DC,mfp^.mm);
XP.x := mfp^.xExt;
YP.y := mfp^.yExt;
SetViewportOrg(DC,0,0);
LPtoDP(DC,XP,1);LPtoDP(DC,YP,1); {get nominal size of image}
SetMapMode(DC,om);
GlobalUnlock(H);
X:=abs(XP.x); Y:= abs(YP.Y);
if (X=0) or (Y=0) then
begin
X:=CR.Right;Y:=CR.Bottom;
end;
end;
procedure RenderPICT(H:THandle;DC:HDC;HWin:HWnd;SR:TRect);
var
om:Integer;
mfp:PMetaFilePict;
X,Y:LongInt;
MaxXY:LongInt;
begin
if H = 0 then Exit;
X:=SR.Right;Y:=SR.Bottom;
MaxXY:=LongMax(X,Y);
mfp := GlobalLock(H);
om := SetMapMode(DC,mfp^.mm);
SetViewportOrg(DC,0,0);
SetViewPortExt(DC,X,Y);
PlayMetaFile(DC,mfp^.hMF);
GlobalUnlock(H);
SetMapMode(DC,oM);
end;
function PICTtoBMP(H:THandle;DC:HDC;HWin:HWnd;SR:TRect):HBitmap;
var
RC:TRect;
om:Integer;
hB,oB:HBitmap;
MemDC:hDC;
X,Y,Size:LongInt;
MaxXY:LongInt;
begin
PICTtoBMP := 0;
if H = 0 then Exit;
GetPICTSize(H,DC,HWin,X,Y);
MaxXY:=LongMax(X,Y);
SetRect(RC,0,0,SR.Right * X div MaxXY,SR.Bottom * Y div MaxXY);
memDC := CreateCompatibleDC(DC);
hB := CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
oB:=SelectObject(memDC,hB);
FillRect(memDC,RC,GetStockObject(WHITE_BRUSH));
RenderPict(H,memDC,HWin,RC);
SelectObject(memDC,oB);
DeleteDC(memDC);
PICTtoBMP:= hB;
end;
{************************* TClipObj *******************************}
constructor TClipObj.Init(hW:hWnd;var Stat:Word;SRect:TRect);
begin
TObject.Init;
SR:=SRect;
IsPrefText := True;
GetClip(hW,Stat);
if Stat <> id_Ok then
Fail;
end;
procedure TClipObj.GetClip(hW : hWnd;var Stat:Word);
var
H : THandle;
hB : HBitmap;
DC : hDC;
nF :Word;
nN :Array[0..50] of Char;
cF :Integer;
nH :THandle;
Indx :Integer;
Clip :PClipItem;
begin
H := 0;hText := 0;hPal := 0;hDIB := 0;hPICT := 0;
hNative := 0;nF := 0;hBMP := 0;hDISP:=0;
Stat := st_ClipFailure;
if NOT OpenClipboard(hW) then EXIT;
Stat := st_OK;
Clips := New(PClipC,Init(10,10));
cF :=CountClipboardFormats;
for Indx := 0 to Pred(cF) do
begin
nF := EnumClipboardFormats(nF);
StrCopy(nN,'');
GetClipboardFormatName(nF,nN,50);
H := GetClipboardData(nF);
if H = 0 then
{ignore these, usually owner-draw}
else if (StrLIComp(nN,'MGX',3) = 0) then
{lets skip this SOB}
else
begin
case nF of
CF_DIB:
begin
nH :=CopyGHND(H);
Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
hDIB := nH;
end;
CF_PALETTE:
begin
nH := CopyPal(H);
Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
hPAL := nH;
end;
CF_BITMAP:
begin
DC := GetDC(HW);
nH := CopyBMP(H,DC);
Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
ReleaseDC(hW,DC);
hBMP := nH;
end;
CF_METAFILEPICT:
begin
nH := CopyPICT(H);
Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
hPICT := nH;
end;
CF_TEXT:
begin
nH :=CopyGHND(H);
Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
hText:= nH;
end;
else
begin
nH :=CopyGHND(H);
Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
if StrIComp('Native',nN) = 0 then hNative := nH;
end;
end;
end;
end;
CloseClipboard;
if Stat = st_OK then {Build graphic thumbnail}
begin
if (hDIB > 0) then
hDisp:=DIBtoBMPScaled(hDIB,hW,SR)
else if (hBMP>0) then
begin
DC:=GetDC(HW);
hDISP:=ScaleBMP(hBMP,hPAL,DC,SR);
releaseDC(HW,DC);
end
else if (hPict>0) then
begin
DC:=GetDC(HW);
hDISP:= PICTtoBMP(hPICT,DC,hW,SR);
releaseDC(HW,DC);
end;
end
else {if failure, dealloc objects}
for Indx := 0 to Pred(Clips^.Count) do
begin
Clip := Clips^.At(Indx);
case Clip^.CFormat of
CF_PALETTE:
DeleteObject(Clip^.CHandle);
CF_BITMAP:
DeleteObject(Clip^.CHandle);
CF_METAFILEPICT:
DelPICT(Clip^.CHandle);
else
GlobalFree(Clip^.CHandle);
end;
end;
Status := Stat;
end;
procedure TClipObj.CopyClip(hW : hWnd);
var
DC : hDC;
oP : hPalette;
cSize : LongInt;
Clip:PClipItem;
nH:THandle;
Indx:Integer;
begin
Status := st_ClipFailure;
if NOT OpenClipboard(hW) then EXIT;
EmptyClipboard;
for Indx := 0 to Pred(Clips^.Count) do
begin
Clip := Clips^.At(Indx);
case Clip^.CFormat of
CF_DIB:
begin
nH :=CopyGHND(Clip^.CHandle);
SetClipboardData(Clip^.CFormat,nH);
end;
CF_PALETTE:
begin
nH := CopyPal(Clip^.CHandle);
SetClipboardData(Clip^.CFormat,nH);
end;
CF_BITMAP:
begin
DC := GetDC(HW);
if hPAL > 0 then oP:=SelectPalette(DC,hPAL,false);
RealizePalette(DC);
nH := CopyBMP(Clip^.CHandle,DC);
if hPAL > 0 then SelectPalette(DC,oP,false);
SetClipboardData(Clip^.CFormat,nH);
ReleaseDC(hW,DC);
end;
CF_METAFILEPICT:
begin
nH := CopyPICT(Clip^.CHandle);
SetClipboardData(Clip^.CFormat,nH);
end;
CF_TEXT:
begin
nH :=CopyGHND(Clip^.CHandle);
SetClipboardData(Clip^.CFormat,nH);
end;
else
begin
nH :=CopyGHND(Clip^.CHandle);
SetClipboardData(Clip^.CFormat,nH);
end;
end;
end;
CloseClipboard;
end;
destructor TClipObj.Done;
var
Indx:Integer;
Clip:PClipItem;
begin
for Indx := 0 to Pred(Clips^.Count) do
begin
Clip := Clips^.At(Indx);
case Clip^.CFormat of
CF_DIB:
GlobalFree(Clip^.CHandle);
CF_PALETTE:
DeleteObject(Clip^.CHandle);
CF_BITMAP:
DeleteObject(Clip^.CHandle);
CF_METAFILEPICT:
DelPICT(Clip^.CHandle);
CF_TEXT:
GlobalFree(Clip^.CHandle);
else
GlobalFree(Clip^.CHandle);
end;
end;
if hDisp >0 then DeleteObject(hDISP);
Dispose(Clips,Done);
TObject.Done;
end;
procedure TClipObj.RenderSelf(DC:hDC;hWin:HWnd);
var
oP:hPalette;
tb:TBitmap;
oB:HBitmap;
pBits:Pointer;
bi:PBitmapInfo;
pT:Pointer;
CR:TRect;
memDC:hDC;
begin
if ((hText=0) and (hDisp=0)) then EXIT;
if ((hText > 0) and IsPrefText) or
(hDisp=0) then
begin
pT := GlobalLock(hText);
GetClientRect(hWin,CR);
SetBkMode(DC,transparent);
DrawText(DC,pT,-1,CR,DT_Left);
GlobalUnlock(hText);
end
else if hDISP > 0 then
begin
if hPal > 0 then oP := SelectPalette(DC,hPal,False);
if hPal > 0 then RealizePalette(DC);
GetObject(hDISP,sizeof(TBitmap),@tb);
memDC:=CreateCompatibleDC(DC);
oB:=SelectObject(memDC,hDISP);
BitBlt(DC,0,0,tb.bmWidth,tb.bmHeight,memDC,0,0,SRCCOPY);
if hPal > 0 then SelectPalette(DC,oP,False);
SelectObject(memDC,oB);
DeleteDC(memDC);
end;
end;
procedure TClipObj.RedrawSelf(DC:hDC;hWin:HWnd);
var
pBits:Pointer;
bi:PBitmapInfo;
pT:Pointer;
CR:TRect;
tb:TBitmap;
memDC:hDC;
oB:HBitmap;
begin
if ((hText=0) and (hDisp=0)) then EXIT;
if ((hText > 0) and IsPrefText) or
(hDisp=0) then
begin
pT := GlobalLock(hText);
GetClientRect(hWin,CR);
SetBkMode(DC,transparent);
DrawText(DC,pT,-1,CR,DT_Left);
GlobalUnlock(hText);
end
else if hDISP > 0 then
begin
GetObject(hDISP,sizeof(TBitmap),@tb);
memDC:=CreateCompatibleDC(DC);
oB:=SelectObject(memDC,hDISP);
BitBlt(DC,0,0,tb.bmWidth,tb.bmHeight,memDC,0,0,SRCCOPY);
SelectObject(memDC,oB);
DeleteDC(memDC);
end;
end;
function TClipObj.GetStatus : Word;
begin
GetStatus := Status;
end;
function TClipObj.GetPal : hPalette;
begin
GetPal := hPal;
end;
function TClipObj.GetDIB : THandle;
begin
GetDIB := hDIB;
end;
function TClipObj.GetPICT : THandle;
begin
GetPICT := hPICT;
end;
procedure TClipObj.GetInfo(Info:PChar;Len:Integer);
type
ORec = Record
DIBSize:Word;
Width:Word;
Height:Word;
Res:Word;
end;
PRec = Record
Size:Word;
end;
var
Size:LongInt;
H : THandle;
bi : PBitmapInfo;
O :ORec;
P :PRec;
Buf :Array[0..100] of Char;
pMFP :PMetaFilePict;
begin
fillchar(O,sizeOf(ORec),0);
fillchar(P,sizeof(PRec),0);
StrCopy(Info,'');
H := GetDIB;
if H <> 0 then
begin
bi := GlobalLock(H);
if bi <> nil then
begin
with bi^.bmiHeader, O do
if bi <> nil then
begin
Width := biWidth;
Height := biHeight;
Res := biBitCount;
end;
GlobalUnlock(hDIB);
O.DIBSize := GlobalSize(hDIB) div 1024;
wvsprintf(Buf,'DIB:%uK %u*%u*%u ',O) ;
StrCat(Info,Buf);
end;
end;
if hPICT <> 0 then
begin
pMFP := GlobalLock(hPICT);
P.Size := GlobalSize(pMFP^.hMF) div 1024;
GlobalUnlock(hPICT);
wvsprintf(Buf,'PICT:%iK',P);
StrCat(Info,Buf);
end;
if hNative <> 0 then
begin
P.Size := GlobalSize(hNative) div 1024;
wvsprintf(Buf,' Native:%iK',P);
StrCat(Info,Buf);
end;
if hText > 0 then
begin
P.Size := GlobalSize(hText) ;
if P.Size > 1024 then
begin
P.Size := P.Size div 1024;
wvsprintf(Buf,'Text:%iK',P);
end
else
wvsprintf(Buf,'Text:%i Bytes',P);
StrCat(Info,Buf);
end;
end;
procedure TClipObj.SetIsPrefText(Choice:Bool);
begin
IsPrefText := Choice;
end;
procedure TClipObj.ToggleIsPrefText;
begin
IsPrefText := not IsPrefText;
end;
procedure TClipObj.GetFormats(Buf:PChar);
begin
if Buf <> nil then
begin
if (hDisp>0) and (hText>0) then
StrCopy(Buf,'*')
else
StrCopy(Buf,'');
end;
end;
{**************************** TClipC ***************************}
constructor TClipC.Init(ALimit,ADelta:Integer);
begin
TCollection.Init(ALimit,ADelta);
end;
destructor TClipC.Done;
begin
TCollection.Done;
end;
{******************************** TClipItem ********************}
constructor TClipItem.Init(NewCHandle:THandle;NewCName:PChar;NewCFormat:Word);
begin
CHandle := NewCHandle;
CName :=StrNew(NewCName);
CFormat := NewCFormat;
end;
destructor TClipItem.Done;
begin
StrDispose(CName);
end;
end.